home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue30 / crossref / CRefCode / CrossF.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1997-11-18  |  9.1 KB  |  324 lines
  1. unit CrossF;
  2.  
  3. interface
  4.  
  5. uses
  6.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  7.   StdCtrls, FileCtrl, ComCtrls;
  8.  
  9. type
  10.   TFormCrossRef = class(TForm)
  11.     FileListBox1: TFileListBox;
  12.     ButtonFiles: TButton;
  13.     EditPath: TEdit;
  14.     ListBoxFiles: TListBox;
  15.     ButtonWords: TButton;
  16.     ButtonHtml: TButton;
  17.     lbList: TListBox;
  18.     ProgressBar1: TProgressBar;
  19.     lbSkip: TListBox;
  20.     Button1: TButton;
  21.     PageControl1: TPageControl;
  22.     Label1: TLabel;
  23.     EditBookDescription: TEdit;
  24.     Label2: TLabel;
  25.     procedure ButtonFilesClick(Sender: TObject);
  26.     procedure ButtonWordsClick(Sender: TObject);
  27.     procedure LbWordsDblClick(Sender: TObject);
  28.     procedure LbWordsClick(Sender: TObject);
  29.     procedure ButtonHtmlClick(Sender: TObject);
  30.     procedure Button1Click(Sender: TObject);
  31.     procedure FormCreate(Sender: TObject);
  32.     procedure FormClose(Sender: TObject; var Action: TCloseAction);
  33.   private
  34.     LetterLists: array ['A'..'Z'] of TListBox;
  35.   public
  36.     procedure ExamineDir (Mask: string);
  37.   end;
  38.  
  39. var
  40.   FormCrossRef: TFormCrossRef;
  41.  
  42. implementation
  43.  
  44. uses
  45.   Newparse;
  46.  
  47. {$R *.DFM}
  48.  
  49. // support functions, borrowed from HTTP
  50.  
  51. function TranslateChar(const Str: string; FromChar, ToChar: Char): string;
  52. var
  53.   I: Integer;
  54. begin
  55.   Result := Str;
  56.   for I := 1 to Length(Result) do
  57.     if Result[I] = FromChar then
  58.       Result[I] := ToChar;
  59. end;
  60.  
  61. function DosPathToUnixPath(const Path: string): string;
  62. begin
  63.   Result := TranslateChar(Path, '\', '/');
  64. end;
  65.  
  66. // form code
  67.  
  68. procedure TFormCrossRef.ButtonFilesClick(Sender: TObject);
  69. begin
  70.   ListBoxFiles.Items.Clear;
  71.   {list all the files with the following extensions
  72.   in the ListBoxFiles list box, looking in all the
  73.   sub-directories of the indicated path}
  74.   FileListbox1.Directory := EditPath.Text;
  75.   ExamineDir ('*.pas');
  76.   ExamineDir ('*.dpr');
  77.   ExamineDir ('*.dpk');
  78.   Beep;
  79. end;
  80.  
  81. procedure TFormCrossRef.ExamineDir (Mask: string);
  82. var
  83.   FileList: TStrings;
  84.   I: Integer;
  85.   CurrDir: string;
  86. begin
  87.   FileListBox1.Mask := Mask;
  88.   FileListBox1.FileType := [ftNormal];
  89.   FileList := TStringList.Create;
  90.   try
  91.     FileList.Assign(FileListBox1.Items);
  92.     // for each file, add its path to the list
  93.     for I := 0 to FileList.Count - 1 do
  94.     begin
  95.       ListBoxFiles.Items.Add (FileListbox1.Directory +
  96.         '\' + FileList[I]);
  97.     end;
  98.     // examine sub directories
  99.     FileListBox1.Mask := '*.*';
  100.     FileListBox1.FileType := [ftDirectory];
  101.     FileList.Assign(FileListBox1.Items);
  102.     CurrDir := FileListbox1.Directory;
  103.     for I := 2 to FileList.Count - 1 do
  104.     begin
  105.       // for each directory, re-examine (recursive call)
  106.       FileListbox1.Directory :=
  107.         CurrDir + '\' + Copy (FileList[I], 2, Length (FileList [I]) - 2);
  108.       ExamineDir (Mask);
  109.       Application.ProcessMessages;
  110.     end;
  111.     FileListbox1.Directory := CurrDir;
  112.   finally
  113.     FileList.Free;
  114.   end;
  115. end;
  116.  
  117. procedure TFormCrossRef.ButtonWordsClick(Sender: TObject);
  118. var
  119.   CurrFile, TokenStr: string;
  120.   I, Item, Idx: Integer;
  121.   FileText: TStream;
  122.   Parse: TNewParser;
  123.   sList: TStringList;
  124. //  StartTime: TTime;
  125.   LettList: TListBox;
  126. begin
  127. //  StartTime := Now;
  128.   // for each file listed
  129.   ProgressBar1.Max := ListBoxFiles.Items.Count - 1;
  130.   for I := 0 to ListBoxFiles.Items.Count - 1 do
  131.   begin
  132.     // select the current file, to show the progress
  133.     ListBoxFiles.ItemIndex := I;
  134.     // get the current file
  135.     CurrFile := ListBoxFiles.Items [I];
  136.     // open it as a text file
  137.     FileText := TFileStream.Create (CurrFile, fmOpenRead);
  138.     // pass the file to the custom parser
  139.     Parse := TNewParser.Create (FileText);
  140.     try
  141.       while Parse.Token <> toEOF do
  142.       begin
  143.         case Parse.Token of
  144.           // ignore strings, comments, symbols...
  145.           toSymbol:
  146.           begin
  147.             TokenStr := Parse.TokenString;
  148.             // more than one character
  149.             if (Length (TokenStr) > 1) and
  150.               // doesn't end with a number
  151.               (TokenStr [Length (TokenStr)] > 'A') and
  152.               // not in the skip list
  153.               (lbSkip.Items.IndexOf (TokenStr) < 0) then
  154.             begin
  155.               // get the listbox for the current letter
  156.               LettList := LetterLists[Upcase(TokenStr[1])];
  157.               // look if the token is already in the list of found tokens
  158.               // for the current letter
  159.               Item := LettList.Items.IndexOf (TokenStr);
  160.               if Item < 0 then
  161.               begin
  162.                 // if not, create a new string list for the files
  163.                 sList := TStringList.Create;
  164.                 sList.Sorted := True;
  165.                 sList.Add (CurrFile);
  166.                 // add the new word and the string list
  167.                 LettList.Items.AddObject (TokenStr, sList);
  168.               end
  169.               else
  170.               begin
  171.                 // add the new file reference
  172.                 sList := TStringList(LettList.Items.Objects[Item]);
  173.                 Idx := sList.IndexOf (CurrFile);
  174.                 if Idx < 0 then
  175.                   sList.Add (CurrFile);
  176.               end;
  177.             end;
  178.           end;
  179.         end;
  180.         Parse.NextToken;
  181.         Application.ProcessMessages;
  182.       end;
  183.     finally
  184.       Parse.Free;
  185.       FileText.Free;
  186.     end;
  187.     ProgressBar1.Position := I;
  188.   end;
  189.   Beep;
  190. //  ShowMessage ('Elapsed: ' + TimeToStr (StartTime - Now));
  191. end;
  192.  
  193. procedure TFormCrossRef.LbWordsDblClick(Sender: TObject);
  194. begin
  195.   // move to the list of skip items
  196.   with (Sender as TListBox) do
  197.   begin
  198.     // destroy the connected string list
  199.     TStringList (Items.Objects [ItemIndex]).Free;
  200.     // add the item to the skip list
  201.     lbSkip.Items.Add (Items[ItemIndex]);
  202.     // remove the item
  203.     Items.Delete (ItemIndex);
  204.   end;
  205. end;
  206.  
  207. procedure TFormCrossRef.LbWordsClick(Sender: TObject);
  208. begin
  209.   // show the list of files
  210.   with (Sender as TListBox) do
  211.     lbList.Items := TStringList (Items.Objects [ItemIndex]);
  212. end;
  213.  
  214. // create the HTML files...
  215. procedure TFormCrossRef.ButtonHtmlClick(Sender: TObject);
  216. var
  217.   Dest: TStream;
  218.   HTML, OutFileName: string;
  219.   I, J: Integer;
  220.   Letter: Char;
  221.   sList: TStringList;
  222. begin
  223.   FileListBox1.Mask := '*.dpr';
  224.   FileListBox1.FileType := [ftNormal];
  225.   SetLength (HTML, 10000);
  226.   // for each letter
  227.   for Letter := 'A' to 'Z' do
  228.   begin
  229.     // select the tab sheet we are working on
  230.     PageControl1.ActivePage :=
  231.       LetterLists [Letter].Parent as TTabSheet;
  232.     HTML := '';
  233.     // add head
  234.     HTML :=
  235.       '<HTML><HEAD>' + #13#10 +
  236.         '<TITLE>CrossReference</TITLE>' + #13#10 +
  237.         '<META NAME="GENERATOR" CONTENT="CrossRef[Marco Cant∙]">' + #13#10 +
  238.         '</HEAD>'#13#10 +
  239.       '<BODY>'#13#10 +
  240.       '<CENTER><I>' + EditBookDescription.Text
  241.         + '</I></CENTER></H3><BR><BR>'#13#10 +
  242.       '<H1><CENTER>Cross Reference: ' +
  243.         Letter + '</CENTER></H1><BR><BR><HR>'#13#10;
  244.     // for each identifier starting with the letter
  245.     for I := 0 to LetterLists [Letter].Items.Count - 1 do
  246.     begin
  247.       Application.ProcessMessages;
  248.       // add the word
  249.       AppendStr (HTML, '<H4>' + LetterLists [Letter].
  250.         Items[I] + '</H4>'#13#10);
  251.       // sub-list
  252.       AppendStr (HTML, '<UL>'#13#10);
  253.       sList := TStringList (LetterLists [Letter].Items.Objects [I]);
  254.       // add file names
  255.       for J := 0 to sList.Count - 1 do
  256.         AppendStr (HTML, '<LI><A HREF="' +
  257.           ChangeFileExt (DosPathToUnixPath (
  258.             Copy (sList[J], Length (EditPath.Text) + 1, 1000)),
  259.             '_' + Copy (ExtractFileExt(sList[J]), 2, 3)) +
  260.             '.htm ">' +
  261.             Copy (sList[J], Length (EditPath.Text) + 1, 1000) +
  262.             '</A>'#13#10);
  263.       AppendStr (HTML, '</UL>'#13#10);
  264.     end;
  265.     // add tail
  266.     AppendStr (HTML,
  267.       '<BR><I><CENTER>' +
  268.       'File generated by CrossRef, a tool by Marco Cantù' +
  269.       '</CENTER></I>'#13#10 +
  270.       '</BODY> </HTML>');
  271.     // create the output file
  272.     OutFileName := EditPath.Text + Letter + '.htm';
  273.     Dest := TFileStream.Create (OutFileName,
  274.       fmCreate or fmOpenWrite or fmShareDenyNone);
  275.     try
  276.       Dest.WriteBuffer (Pointer(HTML)^, Length (HTML));
  277.     finally
  278.       Dest.Free;
  279.     end;
  280.   end; // for Letter
  281.   Beep; // done
  282. end;
  283.  
  284. procedure TFormCrossRef.Button1Click(Sender: TObject);
  285. begin
  286.   with TSaveDialog.Create (nil) do
  287.   begin
  288.     if Execute then
  289.       LbSkip.Items.SaveToFile (FileName);
  290.     Free;
  291.   end;
  292. end;
  293.  
  294. procedure TFormCrossRef.FormCreate(Sender: TObject);
  295. var
  296.   Letter: Char;
  297.   List : TListBox;
  298.   Sheet: TTabSheet;
  299. begin
  300.   // create 26 list boxes, and connects them...
  301.   for Letter := 'A' to 'Z' do
  302.   begin
  303.     Sheet := TTabSheet.Create (self);
  304.     Sheet.PageControl := PageControl1;
  305.     Sheet.Caption := Letter;
  306.     List := TListBox.Create (self);
  307.     List.Parent := Sheet;
  308.     List.Align := alClient;
  309.     List.Sorted := True;
  310.     List.OnClick := LbWordsClick;
  311.     List.OnDblClick := LbWordsDblClick;
  312.     LetterLists [Letter] := List;
  313.   end;
  314. end;
  315.  
  316. procedure TFormCrossRef.FormClose(Sender: TObject;
  317.   var Action: TCloseAction);
  318. begin
  319.   Action := caFree;
  320.   FormCrossRef := nil;
  321. end;
  322.  
  323. end.
  324.